home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / lisp / guile-ii.src / guile-ii / guile-src / libguile / lvectors.c < prev    next >
Encoding:
C/C++ Source or Header  |  1995-08-17  |  11.0 KB  |  454 lines
  1. /*    Copyright (C) 1995 Free Software Foundation, Inc.
  2.  * 
  3.  * This program is free software; you can redistribute it and/or modify
  4.  * it under the terms of the GNU General Public License as published by
  5.  * the Free Software Foundation; either version 2, or (at your option)
  6.  * any later version.
  7.  * 
  8.  * This program is distributed in the hope that it will be useful,
  9.  * but WITHOUT ANY WARRANTY; without even the implied warranty of
  10.  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  11.  * GNU General Public License for more details.
  12.  * 
  13.  * You should have received a copy of the GNU General Public License
  14.  * along with this software; see the file COPYING.  If not, write to
  15.  * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  16.  *
  17.  * As a special exception, the Free Software Foundation gives permission
  18.  * for additional uses of the text contained in its release of GUILE.
  19.  *
  20.  * The exception is that, if you link the GUILE library with other files
  21.  * to produce an executable, this does not by itself cause the
  22.  * resulting executable to be covered by the GNU General Public License.
  23.  * Your use of that executable is in no way restricted on account of
  24.  * linking the GUILE library code into it.
  25.  *
  26.  * This exception does not however invalidate any other reasons why
  27.  * the executable file might be covered by the GNU General Public License.
  28.  *
  29.  * This exception applies only to the code released by the
  30.  * Free Software Foundation under the name GUILE.  If you copy
  31.  * code from other Free Software Foundation releases into a copy of
  32.  * GUILE, as the General Public License permits, the exception does
  33.  * not apply to the code that you add in this way.  To avoid misleading
  34.  * anyone as to the status of such modified files, you must delete
  35.  * this exception notice from them.
  36.  *
  37.  * If you write modifications of your own for GUILE, it is your choice
  38.  * whether to permit this exception to apply to your modifications.
  39.  * If you do not wish that, delete this exception notice.  
  40.  */
  41.  
  42. #include <stdio.h>
  43. #include "_scm.h"
  44.  
  45.  
  46. /* {Locked Vectors}
  47.  */
  48.  
  49. /* Return the Nth lvector hook function or #f it 
  50.  * was not provided. 
  51.  */
  52. static SCM f_lvector_ref;
  53.  
  54. #ifdef __STDC__
  55. SCM
  56. scm_get_lvector_hook (SCM vec, int index)
  57. #else
  58. SCM
  59. scm_get_lvector_hook (vec, index)
  60.      SCM vec;
  61.      int index;
  62. #endif
  63. {
  64.   SCM keyvec;
  65.   SCM hooks;
  66.   keyvec = VELTS (vec)[0];
  67.  
  68.   if (   IMP (keyvec)
  69.       || !VECTORP (keyvec)
  70.       || (LENGTH (keyvec) != 0))
  71.     return BOOL_F;
  72.  
  73.   hooks = VELTS (keyvec)[0];
  74.  
  75.   if (   IMP (hooks)
  76.       || !LVECTORP (hooks)
  77.       || (index >= LENGTH (hooks))
  78.       || (LVECTOR_KEY (hooks, index) != f_lvector_ref))
  79.       return BOOL_F;
  80.  
  81.   return VELTS (hooks)[index];
  82. }
  83.  
  84. PROC (s_lvector_isa_p, "lvector-isa?", 2, 0, 0, scm_lvector_isa_p);
  85. #ifdef __STDC__
  86. SCM
  87. scm_lvector_isa_p (SCM vec, SCM keyvec)
  88. #else
  89. SCM
  90. scm_lvector_isa_p (vec, keyvec)
  91.      SCM vec;
  92.      SCM keyvec;
  93. #endif
  94. {
  95.   ASSERT (NIMP (vec) && LVECTORP (vec), vec, ARG1, s_lvector_isa_p);
  96.   if (keyvec == VELTS (vec)[0])
  97.     return BOOL_T;
  98.   {
  99.     SCM hook;
  100.  
  101.     hook = scm_get_lvector_hook (vec, LV_ISA_FN);
  102.     if (hook == BOOL_F)
  103.       return BOOL_F;
  104.     return scm_apply (hook, scm_cons (vec, scm_cons (keyvec, EOL)), EOL);
  105.   }
  106. }
  107.  
  108.  
  109. PROC (s_lvector_set_x, "lvector-set!", 4, 1, 0, scm_lvector_set_x);
  110. #ifdef __STDC__
  111. SCM
  112. scm_lvector_set_x (SCM vec, SCM key, SCM index, SCM val, SCM rock)
  113. #else
  114. SCM
  115. scm_lvector_set_x (vec, key, index, val, rock)
  116.      SCM vec;
  117.      SCM key;
  118.      SCM index;
  119.      SCM val;
  120.      SCM rock;
  121. #endif
  122. {
  123.   int i;
  124.   ASSERT ( NIMP (vec) && LVECTORP (vec), vec, ARG1, s_lvector_set_x );
  125.   ASSERT ( INUMP (index), index, ARG2, s_lvector_set_x );
  126.   ASSERT ( INUM (index) < LENGTH (vec), index, OUTOFRANGE, s_lvector_set_x );
  127.   i = INUM (index);
  128.  
  129.   if (key == VELTS (VELTS (vec)[0])[i])
  130.     {
  131.       VELTS (vec)[i] = val;
  132.       return UNSPECIFIED;
  133.     }
  134.   else
  135.   {
  136.     SCM hook;
  137.     hook = scm_get_lvector_hook (vec, LV_SET_FN);
  138.     ASSERT (hook != BOOL_F,
  139.         key,
  140.         "wrong key for locked vector element:", s_lvector_set_x);
  141.     
  142.     return scm_apply (hook,
  143.               scm_listify (vec, key, index, val,
  144.                    rock, SCM_UNDEFINED), EOL);
  145.   }
  146. }
  147.  
  148. PROC (s_lvector_poke_x, "lvector-poke!", 3, 0, 0, scm_lvector_poke_x);
  149. #ifdef __STDC__
  150. SCM
  151. scm_lvector_poke_x (SCM vec, SCM index, SCM val)
  152. #else
  153. SCM
  154. scm_lvector_poke_x (vec, index, val)
  155.      SCM vec;
  156.      SCM index;
  157.      SCM val;
  158. #endif
  159. {
  160.   int i;
  161.   ASSERT ( NIMP (vec) && LVECTORP (vec), vec, ARG1, s_lvector_poke_x );
  162.   ASSERT ( INUMP (index), index, ARG2, s_lvector_poke_x );
  163.   ASSERT ( INUM (index) < LENGTH (vec), index, OUTOFRANGE, s_lvector_poke_x );
  164.   i = INUM (index);
  165.   VELTS (vec)[i] = val;
  166.   return UNSPECIFIED;
  167. }
  168.  
  169.  
  170. PROC (s_lvector_ref, "lvector-ref", 3, 0, 0, scm_lvector_ref);
  171. #ifdef __STDC__
  172. SCM
  173. scm_lvector_ref (SCM vec, SCM key, SCM index)
  174. #else
  175. SCM
  176. scm_lvector_ref (vec, key, index)
  177.      SCM vec;
  178.      SCM key;
  179.      SCM index;
  180. #endif
  181. {
  182.   SCM keyvec;
  183.   SCM answer;
  184.   int i;
  185.   ASSERT ( NIMP (vec) && LVECTORP (vec), vec, ARG1, s_lvector_ref );
  186.   keyvec = VELTS (vec)[0];
  187.   ASSERT ( INUMP (index), index, ARG2, s_lvector_ref );
  188.   i = INUM (index);
  189.   ASSERT ( INUM (index) < LENGTH (vec), index, OUTOFRANGE, s_lvector_ref );
  190.   answer = VELTS (vec)[i];
  191.   if (key == VELTS (keyvec)[i])
  192.     return answer;
  193.  
  194.   {
  195.     SCM hook;
  196.     hook = scm_get_lvector_hook (vec, LV_REF_FN);
  197.     ASSERT (hook != BOOL_F,
  198.         key,
  199.         "wrong key for locked vector element:", s_lvector_set_x);
  200.     
  201.     return scm_apply (hook,
  202.               scm_cons (vec, scm_cons (key, scm_cons (index, EOL))),
  203.               EOL);
  204.   }
  205. }
  206.  
  207. PROC (s_lvector_ref2, "lvector-ref2", 3, 1, 0, scm_lvector_ref2);
  208. #ifdef __STDC__
  209. SCM
  210. scm_lvector_ref2 (SCM vec, SCM key, SCM index, SCM rock)
  211. #else
  212. SCM
  213. scm_lvector_ref2 (vec, key, index, rock)
  214.      SCM vec;
  215.      SCM key;
  216.      SCM index;
  217.      SCM rock;
  218. #endif
  219. {
  220.   SCM keyvec;
  221.   SCM answer;
  222.   int i;
  223.   ASSERT ( NIMP (vec) && LVECTORP (vec), vec, ARG1, s_lvector_ref );
  224.   keyvec = VELTS (vec)[0];
  225.   ASSERT ( INUMP (index), index, ARG2, s_lvector_ref );
  226.   i = INUM (index);
  227.   if (i < LENGTH (vec))
  228.    {
  229.      answer = VELTS (vec)[i];
  230.      if (key == VELTS (keyvec)[i])
  231.        return answer;
  232.    }
  233.   {
  234.     SCM hook;
  235.     hook = scm_get_lvector_hook (vec, LV_REF_FN);
  236.     ASSERT (hook != BOOL_F,
  237.         key,
  238.         "wrong key for locked vector element:", s_lvector_set_x);
  239.     
  240.     return scm_apply (hook,
  241.               scm_listify (vec, key, index, rock, SCM_UNDEFINED),
  242.               EOL);
  243.   }
  244. }
  245.  
  246.  
  247. PROC (s_lvector_peek, "lvector-peek", 2, 0, 0, scm_lvector_peek);
  248. #ifdef __STDC__
  249. SCM
  250. scm_lvector_peek (SCM vec, SCM index)
  251. #else
  252. SCM
  253. scm_lvector_peek (vec, index)
  254.      SCM vec;
  255.      SCM index;
  256. #endif
  257. {
  258.   SCM keyvec;
  259.   int i;
  260.   ASSERT ( NIMP (vec) && LVECTORP (vec), vec, ARG1, s_lvector_peek );
  261.   keyvec = VELTS (vec)[0];
  262.   ASSERT ( INUMP (index), index, ARG2, s_lvector_peek );
  263.   i = INUM (index);
  264.   ASSERT ( INUM (index) < LENGTH (vec), index, OUTOFRANGE, s_lvector_peek );
  265.   return VELTS (vec)[i];
  266. }
  267.  
  268.  
  269. #define LVEC_CCL_KEY(C) (VELTS (C) [1])
  270. #define LVEC_CCL_INDEX(C) (VELTS (C) [2])
  271.  
  272. static char s_lvector_accessor1[] = " lvector-accessor-procedure";
  273. #ifdef __STDC__
  274. static SCM
  275. lvector_accessor1 (SCM ccl, SCM lvec)
  276. #else
  277. static SCM
  278. lvector_accessor1 (ccl, lvec)
  279.      SCM ccl;
  280.      SCM lvec;
  281. #endif
  282. {
  283.   ASSERT (NIMP (lvec) && LVECTORP (lvec), lvec, ARG1, s_lvector_accessor1);
  284.   if (LVEC_CCL_KEY (ccl) == VELTS (lvec)[0])
  285.     return VELTS (lvec) [INUM (LVEC_CCL_INDEX (ccl))];
  286.   else
  287.     return scm_lvector_ref (lvec,
  288.                 LVEC_CCL_KEY (ccl),
  289.                 INUM (LVEC_CCL_INDEX (ccl)));
  290. }
  291.  
  292. static char s_lvector_modifier1[] = " lvector-modifier-procedure";
  293.  
  294. #ifdef __STDC__
  295. static SCM
  296. lvector_modifier1 (SCM ccl, SCM lvec, SCM val)
  297. #else
  298. static SCM
  299. lvector_modifier1 (ccl, lvec, val)
  300.      SCM ccl;
  301.      SCM lvec;
  302.      SCM val;
  303. #endif
  304. {
  305.   ASSERT (NIMP (lvec) && LVECTORP (lvec), lvec, ARG1, s_lvector_modifier1);
  306.   if (LVEC_CCL_KEY (ccl) == VELTS (lvec)[0])
  307.     {
  308.       VELTS (lvec) [INUM (LVEC_CCL_INDEX (ccl))] = val;
  309.       return UNSPECIFIED;
  310.     }
  311.   else
  312.     return scm_lvector_set_x (lvec,
  313.                   LVEC_CCL_KEY (ccl), INUM (LVEC_CCL_INDEX (ccl)),
  314.                   val, BOOL_F);
  315. }
  316.  
  317.  
  318. static SCM f_lvector_accessor1;
  319. static SCM f_lvector_modifier1;
  320.  
  321. PROC (s_lvector_accessor, "lvector-accessor", 2, 0, 0, scm_lvector_accessor);
  322. #ifdef __STDC__
  323. SCM
  324. scm_lvector_accessor (SCM type, SCM index)
  325. #else
  326. SCM
  327. scm_lvector_accessor (type, index)
  328.      SCM type;
  329.      SCM index;
  330. #endif
  331. {
  332.   SCM answer;
  333.   ASSERT (NIMP (type) && VECTORP (type), type, ARG1, s_lvector_accessor);
  334.   ASSERT (INUMP (index), index, ARG2, s_lvector_accessor);
  335.   ASSERT (INUM (index) < LENGTH (type), index, OUTOFRANGE, s_lvector_accessor);
  336.   answer = scm_makcclo (f_lvector_accessor1, 3L);
  337.   LVEC_CCL_KEY (answer) = ((type != BOOL_F) ? type : answer);
  338.   LVEC_CCL_INDEX (answer) = index;
  339.   return answer;
  340. }
  341.  
  342.  
  343. PROC (s_lvector_modifier, "lvector-modifier", 2, 0, 0, scm_lvector_modifier);
  344. #ifdef __STDC__
  345. SCM
  346. scm_lvector_modifier (SCM type, SCM index)
  347. #else
  348. SCM
  349. scm_lvector_modifier (type, index)
  350.      SCM type;
  351.      SCM index;
  352. #endif
  353. {
  354.   SCM answer;
  355.   ASSERT (NIMP (type) && VECTORP (type), type, ARG1, s_lvector_modifier);
  356.   ASSERT (INUMP (index), index, ARG2, s_lvector_modifier);
  357.   ASSERT (INUM (index) < LENGTH (type), index, OUTOFRANGE, s_lvector_modifier);
  358.   answer = scm_makcclo (f_lvector_modifier1, 3L);
  359.   LVEC_CCL_KEY (answer) = ((type != BOOL_F) ? type : answer);
  360.   LVEC_CCL_INDEX (answer) = index;
  361.   return answer;
  362. }
  363.  
  364.  
  365. PROC (s_lock_vector_x, "lock-vector!", 1, 0, 0, scm_lock_vector_x);
  366. #ifdef __STDC__
  367. SCM
  368. scm_lock_vector_x (SCM vec)
  369. #else
  370. SCM
  371. scm_lock_vector_x (vec)
  372.      SCM vec;
  373. #endif
  374. {
  375.   SCM keyvec;
  376.   ASSERT (NIMP (vec) && VECTORP (vec), vec, ARG1, s_lock_vector_x);
  377.   ASSERT (LENGTH (vec), vec, "missing key vector as element 0", s_lock_vector_x);
  378.   keyvec = VELTS (vec)[0];
  379.   ASSERT (NIMP (keyvec) && VECTORP (keyvec), vec,
  380.       "bad key vector (element 0)", s_lock_vector_x);
  381.   ASSERT (LENGTH (keyvec) >= LENGTH (vec), vec,
  382.       "key vector too short", s_lock_vector_x);
  383.   SETLENGTH ( vec, LENGTH (vec), tc7_lvector );
  384.   return vec;
  385. }
  386.  
  387.  
  388. PROC (s_unlock_vector_x, "unlock-vector!", 1, 0, 0, scm_unlock_vector_x);
  389. #ifdef __STDC__
  390. SCM
  391. scm_unlock_vector_x (SCM vec)
  392. #else
  393. SCM
  394. scm_unlock_vector_x (vec)
  395.      SCM vec;
  396. #endif
  397. {
  398.   ASSERT (NIMP (vec) && LVECTORP (vec), vec, ARG1, s_unlock_vector_x);
  399.   SETLENGTH ( vec, LENGTH (vec), tc7_vector );
  400.   return vec;
  401. }
  402.  
  403.  
  404. PROC (s_lvector_keys, "lvector-keys", 1, 0, 0, scm_lvector_keys);
  405. #ifdef __STDC__
  406. SCM
  407. scm_lvector_keys (SCM vec)
  408. #else
  409. SCM
  410. scm_lvector_keys (vec)
  411.      SCM vec;
  412. #endif
  413. {
  414.   ASSERT (NIMP (vec) && LVECTORP (vec), vec, ARG1, s_lvector_keys);
  415.   return VELTS (vec)[0];
  416. }
  417.  
  418.  
  419. PROC (s_lvector_p, "lvector?", 1, 0, 0, scm_lvector_p);
  420. #ifdef __STDC__
  421. SCM
  422. scm_lvector_p (SCM vec)
  423. #else
  424. SCM
  425. scm_lvector_p (vec)
  426.      SCM vec;
  427. #endif
  428. {
  429.   return  ((NIMP (vec) && LVECTORP (vec))
  430.        ? BOOL_T
  431.        : BOOL_F);
  432. }
  433.  
  434.  
  435.  
  436.  
  437. #ifdef __STDC__
  438. void
  439. scm_init_lvectors (void)
  440. #else
  441. void
  442. scm_init_lvectors ()
  443. #endif
  444. {
  445.   f_lvector_accessor1 = scm_make_subr (s_lvector_accessor1,
  446.                        tc7_subr_2,
  447.                        lvector_accessor1);
  448.   f_lvector_modifier1 = scm_make_subr (s_lvector_modifier1,
  449.                        tc7_subr_3,
  450.                        lvector_modifier1);
  451. #include "lvectors.x"
  452.   f_lvector_ref = CDR (scm_intern0 (s_lvector_ref));
  453. }
  454.